perm filename FOO[1,LMM]1 blob
sn#070811 filedate 1973-11-11 generic text, type T, neo UTF8
C CONGEN. COMMON AREAS.
IMPLICIT INTEGER (A-Z)
COMMON /CQGR/ QFLG,QPIC,QX(100),QY(100)
COMMON /CFILLIM/ FILLIM,STRCLIM
COMMON /CFFF/ FILEU(80),FILE(80),BLK(80),WRD(80)
1 ,LIM(80)
COMMON /CWHERE/ IWHERE,FCNT,PPN
COMMON /CFFXX/ FN,IEXT,HFILEN(40)
COMMON /CE2SW/ E2SW,E2CNT
COMMON /CFILEN/ HNAM(14),TCH(7),FHNAM(11)
COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
1 ,TERMC,TERMAT(20),TERMV(20)
2 ,INCL,INCLA(20),INCLT(20,4)
COMMON /CATMSOR/ ATMSOR(106)
DATA (ATMSOR(I1),I1=1,106)/
1 13, 15, 18, 36, 27, 11, 62, 38, 14, 55,
2 44, 16, 37, 8, 1, 20, 89, 71, 65, 5,
3 59, 32, 52, 51, 22, 43, 42, 41, 40, 39,
4 6, 23,105,103, 90, 31, 87, 86, 84, 72,
5 12, 67, 9, 64, 63, 29, 61, 60, 28, 58,
6 57, 56, 24, 54, 53, 3, 30, 50, 49, 48,
7 47, 46, 45, 2,106, 7,104, 25,102,101,
8 100, 99, 98, 97, 96, 95, 94, 93, 92, 91,
9 4, 19, 88, 26, 10, 85, 17, 83, 82, 81,
1 80, 79, 78, 77, 76, 75, 74, 73, 21, 35,
2 70, 69, 68, 34, 66, 33/
COMMON /CPOSW/ POSW
COMMON /IO/ CID,COD,E2CID,ICNT,BOD
DATA CID,COD,E2CID /21,1,23/
C-----------------------------------------------------------------------
C THE FOLLOWING BLOCK MUST NOT BE DISTURBED
C 12,033 WORDS
COMMON /CACL/ DUM(4),NEW(1024)
COMMON /CASA/ NUMB,AR(10,100),CDUM(3000)
COMMON /PUSH/ PDUM(3400)
COMMON /CRNGH/ RNGH(120)
COMMON /INA/INA(2)
COMMON /TRBLK/ RAR(256)
COMMON /DDF/DDFILE(10)
COMMON /NMOR/ NN(100),EV(100),PST(100),SA(100)
1 ,Z(2,100),ATS(100),AT(100),ASS(100)
2 ,SUBQ(100),SUBS(100),SUBT(100)
COMMON /CAHA/ HOLDA(100),HOLDB(100),HOLDBB(100)
1 ,HOLDC(100),HOLDD(100),HOLDE(100),
2 R1MARK(100),R2MARK(100),R3MARK(100)
COMMON /MARK/ CT(20),MK(100)
COMMON /CEXT/ DR(10,100)
C-----------------------------------------------------------------------
COMMON /CIOMNI/ IOMNI,IOMDEV,IOFST
COMMON /CBB/ BUFQ(2)
DIMENSION AREQ(10)
EQUIVALENCE (AREQ(1),AR(1,1))
COMMON /CATAS/ ATAS(106)
DATA (ATAS(I1),I1=1,106)/
1 'AC','AG','AL','AM','AR','AS','AT','AU','B','BA','BE','BI',
2 'BK','BR','C','CA','CD','CE','CF','CL','CM','CO','CR','CS',
3 'CU','D','DY','ER','ES','EU','F','FE','FM','FR','GA','GD',
4 'GE','H','HE','HF','HG','HO','I','IN','IR','K','KR','LA',
5 'LI','LU','LW','MD','MG','MN','MO','N','NA','NB','ND','NE',
6 'NI','NO','NP','O','OS','P','PA','PB','PD','PM','PO','PR',
7 'PT','PU','RA','RB','RE','RH','RN','RU','S','SB','SC','SE',
8 'SI','SM','SN','SR','T','TA','TB','TC','TE','TH','TI','TL',
9 'TM','U','V','W','XE','Y','YB','ZN','ZR',' '/
COMMON /QSCALE/ SCALE,SCC
C MAIN PROGRAM BEGINS HERE
IOMNI=0
IOFST=0
IOMDEV=0
SCC=60
POSW=1
QFLG=0
E2SW=2
BNCNT=1
FILLIM=80
STRCLIM=10000
DO 600 I1=1,4
SST(I1)=1
SHUNT(I1)=1
600 CONTINUE
SHUNT(5)=1
DO 609 I1=1,12
FSHUNT(I1)=1
609 CONTINUE
FSHUNT(12)=1
SW=0
INITF=1
DO 70 I1=1,1000
AREQ(I1)=0
70 CONTINUE
NUMB=0
CALL DOEASY
END
SUBROUTINE DOEASY
C DOEASY: MAIN LOOP IS HERE
IMPLICIT INTEGER (A-Z)
COMMON /CQGR/ QFLG,QPIC,QX(100),QY(100)
COMMON /CNEWHLD/ SSTATE(1000)
COMMON /CWHERE/ IWHERE,FCNT,PPN
COMMON /CFFXX/ FN,IEXT,HFILEN(40)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
1 ,TERMC,TERMAT(20),TERMV(20),INCL,INCLA(20),INCLT(20,4)
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
1 ,LSYM,DELTA
COMMON /CGSC/ ATAR(80)
COMMON /CACL/ EKC,UPB,WC,ICC,CARCL(1000)
COMMON /CMI/ DUMCR(106),DUMAT(106),MATX(40),CONX(40),
1 CONXT(6),ATXT(6),ATX(6,40),RCBX(6,40),CC,AACNT(40)
2 ,REGA(10),P(25),LEVEL(12)
COMMON /CSTRC/ STRCNT(11)
COMMON /CAUTO/ IAUTO,IPROP,ICSTAR,IPREVF,IPREVR
COMMON /CL4INT/ ISOCNT
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /CREST/ LNUMB,STATE (1000)
DIMENSION AREQ(10)
EQUIVALENCE (AREQ(1),AR(1,1))
COMMON /IO/ CID,COD
COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
EQUIVALENCE (PROBE,SW)
C DOEASY BEGINS HERE
TERSE=1
TERMC=0
INCL=0
ATHN=0
DELTA=1
BENDARM=2
LNUMB=0
NUMB=0
DO 66621 I1=1,1000
AREQ(I1)=0
66621 CONTINUE
20 CALL CHOICE (AT)
DO 7183 I1=1,1000
STATE(I1)=AREQ(I1)
7183 CONTINUE
LNUMB=NUMB
IF(NUMB .EQ. 0 .OR. AT .NE. 'D') GO TO 21
DO 86 I1=1,1000
SSTATE(I1)=AREQ(I1)
86 CONTINUE
LLNUMB=NUMB
CALL CSRG (2)
C MODE 0 FOR NO NUMBERS IN GMOL MODE 2 FOR NUMBERS
CALL GMOL (0)
QFLG=0
GOTO 20
C-----------------------------------------------------------------
21 IF(NUMB .EQ. 0 .OR. AT .NE. 'Q') GO TO 921
DO 986 I1=1,1000
SSTATE(I1)=AREQ(I1)
986 CONTINUE
LLNUMB=NUMB
CALL CSRG (2)
C MODE 0 FOR NO NUMBERS IN GMOL MODE 2 FOR NUMBERS
CALL GMOL (0)
GOTO 20
C-----------------------------------------------------------------
921 ATHN=NUMB
230 CONTINUE
5111 CONTINUE
IF(AT .NE. 'MORGA') GOTO 5112
CALL NMORGAN
GOTO 20
C-----------------------------------------------------------------
5112 CONTINUE
IF(AT .NE. 'C') GOTO 9264
DO 9265 I1=1,NUMB
DO 9266 I2=10,5,-1
IF(AR(I2,I1) .NE. 0) GOTO 9267
9266 CONTINUE
9267 I4=AR(2,I1)
IF(I4 .EQ. 0) I4='C'
TYPE 9268,I1,I4,(AR(I3,I1),I3=5,I2)
9268 FORMAT(1I3,1X,1A2,1X,6I3)
9265 CONTINUE
GOTO 20
C-----------------------------------------------------------------
9264 CONTINUE
GOTO 20
END
SUBROUTINE CHOICE (AT)
C CHOICE: DECISION ROUTINE
IMPLICIT INTEGER (A-Z)
COMMON /CREST/ LNUMB,STATE (1000)
COMMON /CNEWHLD/ SSTATE(1000)
COMMON /CFILLIM/ FILLIM,STRCLIM
COMMON /CIOMNI/ IOMNI,IOMDEV,IOFST
COMMON /CWHERE/ IWHERE,FCNT,PPN
COMMON /CVTBAR/ VTB,DFSW
DATA DFSW /0/
COMMON /QSCALE/ SCALE,SCC
COMMON /PUSH/ NEWS(1024)
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM,LSYM
1 ,DELTA
DATA LSYM /':'/
COMMON /CATAS/ ATAS(106)
COMMON /CGSC/ ATAR(80)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
1 ,TERMC,TERMAT(20),TERMV(20)
2 ,INCL,INCLA(20),INCLT(20,4)
COMMON /MARK/ TEMP(4)
DATA LEV /8/
DATA TOGG /2/
COMMON /IO/ CID,COD
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
DATA (STT(I1),I1=1,8) /
1 'RING','STIT','STIT','SUBST',
2 'NUC','PATT','SEQ','PATT'/
DIMENSION AREQ (10)
EQUIVALENCE (AREQ(1),AR(1,1))
C CHOICE BEGINS HERE
CALL GSCHAR (AT)
C-----------------------------------------------------------------
IF(AT .NE. 'SYM') GOTO 416
IF(LSYM .EQ. ':') GOTO 645
LSYM=':'
GOTO 416
645 LSYM='*'
C-----------------------------------------------------------------
416 IF(AT .NE. 'FORCE') GOTO 700
TERSE=2
LSYM='*'
SCC=40
GOTO 701
C-----------------------------------------------------------------
700 IF(AT .NE. 'CLEAR') GO TO 20
701 DO 600 I1=1,4
SST(I1)=1
600 SHUNT(I1)=1
SHUNT(5)=1
BNCNT=1
BNINCL(1,1)=0
BNINCL(1,2)=0
LNUMB=0
TERMC=0
INCL=0
DO 21 I1=1,1000
AREQ(I1)=0
STATE(I1)=0
SSTATE(I1)=0
21 CONTINUE
NUMB=0
ATHN=0
C-----------------------------------------------------------------
IF(AT .NE. 'SCALE') GO TO 532
SCC=100-SCC
I1=1
IF(SCC .EQ. 60) I1=2
TYPE 533,I1
533 FORMAT(' SCALE NOW ',1I1/)
532 CONTINUE
20 CONTINUE
END
SUBROUTINE GSCHAR (ICA)
IMPLICIT INTEGER (A-Z)
COMMON /CGSC/ ATAR(80)
TYPE 102
102 FORMAT(' *',$)
ACCEPT 101,ICA,(ATAR(I1),I1=1,10)
101 FORMAT(1A5,1X,10I)
DO 10 I11=10,0,-1
IF(ATAR(I11) .NE. 0) GO TO 11
10 CONTINUE
11 CONTINUE
END
SUBROUTINE EQCL (N1,N2,SYM)
C-----------------------------------------------------------------------
C A TOAD WHICH TOUTS FOR BONDCL
IMPLICIT INTEGER (A-Z)
COMMON /CPCHAR/ PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
DATA FSTSW /0/
DIMENSION BONDMAP(15)
DATA (BONDMAP(I1),I1=1,15)/
1 '*','+','#','%','*','+','#','%',
2 '.','*','*','*','+','#','$'/
COMMON /CBNDST/ BNDST(14)
COMMON /CASA/ NUMB,AR(10,100)
COMMON /CLASS/ BNCNT,BNINCL(50,3)
IF(BNCNT .EQ. 1) RETURN
IF(FSTSW .EQ. 1) GO TO 50
FSTSW=1
BONDMAP(1)=PSINGLE
BONDMAP(2)=PDOUBLE
BONDMAP(3)=PTRIPLE
BONDMAP(4)=PTAUT
BONDMAP(5)=PSINGLE
BONDMAP(6)=PDOUBLE
BONDMAP(7)=PTRIPLE
BONDMAP(8)=PTAUT
BONDMAP(9)=PALT
50 CONTINUE
DO 60 I1=1,BNCNT-1
IF(BNINCL(I1,1) .EQ. N1 .AND. BNINCL(I1,2)
1 .EQ. N2) GO TO 61
IF(BNINCL(I1,1) .EQ. N2 .AND.BNINCL(I1,2)
1 .EQ. N1) GO TO 61
60 CONTINUE
RETURN
61 CONTINUE
I2=BNINCL(I1,3)
SYM=BONDMAP(I2)
END
SUBROUTINE GMOL (II)
C-----------------------------------------------------------------------
IMPLICIT INTEGER (A-Z)
COMMON /CREGNO/ REGNO
COMMON /IO/ CID,COD,E2CID
COMMON /CPCHAR/ PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
DATA PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
1 /'*','+','#','.','%'/
COMMON /CMIRSUP/ MIRSUP
DATA MIRSUP /0/
DATA ERCNT /0/
COMMON /CACL/ DUMM(4),BND(10,100)
COMMON /CATAS/ ATAS(106)
COMMON /MD/ MDX,MDY
COMMON /CASA/ NUMB,AR(10,100),ARP(100,1)
COMMON /CE2SW/ E2SW,E2CNT
COMMON /CIOMNI/ IOMNI,IOMDEV
DATA DCON /20/
DATA DOFF /25/
DIMENSION PT(5)
IF(E2CNT .EQ. 0 .OR. E2SW .EQ. 1) GO TO 300
ERCNT=ERCNT+1
RETURN
300 CONTINUE
CALL CLRAR
MINX=10000
MINY=10000
MAXX=0
MAXY=0
DO 80 I1=1,NUMB
I2=AR(3,I1)
I3=AR(4,I1)
IF(I2 .GT. MAXX)MAXX=I2
IF(I2 .LT. MINX) MINX=I2
IF(I3 .GT. MAXY) MAXY=I3
IF(I3 .LT. MINY) MINY=I3
80 CONTINUE
IF(((MAXY-MINY)-(MAXX-MINX)) .LT. 10) GO TO 81
IF(MIRSUP .EQ. 0) CALL MIRROR
81 CONTINUE
DO 10 I1=1,NUMB
IF(AR(3,I1) .EQ. 0 .OR. AR(4,I1) .EQ. 0) GO TO 11
I2=(AR(3,I1)/DCON)+DOFF
I3=(AR(4,I1)/DCON)+DOFF
I99=AR(2,I1)
IF(II .NE. 2) GO TO 70
CALL QPACN (I99,PT,5)
ARP(I2,I3)=PT(1)
IF(PT(2) .NE. ' ') ARP(I2+1,I3)=PT(2)
GO TO 71
70 CONTINUE
IF(I99 .EQ. 0) I99=' '
ENCODE (5,101,PTT) I1,I99
101 FORMAT(1I2,1A2)
CALL QPACN (PTT,PT,5)
I21=1
IF(PT(1) .EQ. ' ') I21=2
I22=5
IF(PT(4) .EQ. ' ') I22=3
IF(PT(3) .EQ. ' ') I22=2
DO 90 I11=I21,I22
ARP(I2+I11-I21,I3)=PT(I11)
90 CONTINUE
71 CONTINUE
DO 20 I4=5,10
I55=AR(I4,I1)
IF(I55 .EQ. 0) GO TO 60
IF(I55 .LT. I1) GO TO 20
I10=(AR(3,I55)/DCON)+DOFF
I11=(AR(4,I55)/DCON)+DOFF
SYM=PSINGLE
IF(II .EQ. 2) GO TO 510
CALL EQCL (I1,I55,SYM)
GO TO 50
510 CONTINUE
IB=BND(I4,I1)
IF(IB .EQ. 2 .OR. IB .EQ. 6) SYM=PDOUBLE
IF(IB .EQ. 3 .OR. IB .EQ. 7) SYM=PTRIPLE
IF(IB .EQ. 4 .OR. IB .EQ. 8) SYM=PTAUT
IF(IB .EQ. 9) SYM=PALT
50 CONTINUE
CALL LINE (I2,I3,I10,I11,SYM)
20 CONTINUE
60 CONTINUE
10 CONTINUE
CALL GWOUT
RETURN
11 CONTINUE
ERCNT=ERCNT+1
END
SUBROUTINE MIRROR
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,MOLLY(10,100)
DO 31 I2=1,NUMB
IX=MOLLY(3,I2)
IY=MOLLY(4,I2)
MOLLY(3,I2)=IY
MOLLY(4,I2)=IX
31 CONTINUE
END
SUBROUTINE LINE (X1,Y1,X2,Y2,SYM)
C DRAW ANY HORIZ,VERT OR DIAG LINE
IMPLICIT INTEGER (A-Z)
COMMON /CVTBAR/ VTB,DFSW
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM,LSYM
COMMON /CASA/ DDD(1001),AR(100,1)
COMMON /MD/ MDX,MDY
DATA MDX,MDY /100,100/
DATA BKSL,VTBAR /"560000000000,"760000000000/
IF(X1 .EQ. 0 .OR. Y1 .EQ. 0 .OR. X2 .EQ. 0 .OR. Y2 .EQ. 0)
1 CALL WO ('LINE')
IF(Y1 .EQ. Y2) GO TO 10
IF(X1 .NE. X2) GO TO 20
IF(SYM .EQ. LSYM .AND. VTB .EQ. 1) SYM=VTBAR
IF(SYM .EQ. LSYM .AND. VTB .EQ. 0) SYM='↑'
IF(Y1 .LE. Y2) GO TO 1
TY1=Y2
TY2=Y1
GO TO 2
1 CONTINUE
TY1=Y1
TY2=Y2
2 CONTINUE
DO 30 I1=TY1,TY2
IF(I1 .GT. MDY .OR. I1 .LT. 1) GO TO 30
IF(AR(X1,I1) .NE. ' ') GO TO 30
AR(X1,I1)=SYM
30 CONTINUE
RETURN
20 CONTINUE
I4=IABS(X1-X2) +1
TX1=X1
TY1=Y1
TY2=Y2
IF(X1 .LT. X2) GO TO 21
TX1=X2
TY1=Y2
TY2=Y1
21 CONTINUE
IF(TY1 .GT. TY2) GO TO 22
IF(SYM .EQ. LSYM) SYM='/'
DO 50 I1=1,I4
I6=TX1-1+I1
I7=TY1-1+I1
IF(I7 .GT. TY2) I7=TY2
IF(I6 .GT. MDX .OR. I6 .LT. 1 .OR. I7 .GT. MDY .OR. I7 .LT.1)
1 GO TO 50
IF(AR(I6,I7) .NE. ' ') GO TO 50
AR(I6,I7)=SYM
50 CONTINUE
RETURN
22 CONTINUE
IF(SYM .EQ. LSYM) SYM=BKSL
DO 51 I1=1,I4
I6=TX1-1+I1
I7=TY1+1-I1
IF(I7 .LT. TY2) I7=TY2
IF(I6 .GT. MDX .OR. I6 .LT. 1 .OR. I7 .GT. MDY .OR. I7 .LT.1)
1 GO TO 51
IF(AR(I6,I7) .NE. ' ') GO TO 51
AR(I6,I7)=SYM
51 CONTINUE
RETURN
10 CONTINUE
IF(SYM .EQ. LSYM) SYM='-'
IF(X1 .LE. X2) GO TO 11
TX1=X2
TX2=X1
GO TO 12
11 CONTINUE
TX1=X1
TX2=X2
12 CONTINUE
DO 40 I1=TX1,TX2
IF(I1 .GT. MDX .OR. I1 .LT. 1) GO TO 40
IF(AR(I1,Y1) .NE. ' ') GO TO 40
AR(I1,Y1)=SYM
40 CONTINUE
END
SUBROUTINE CLRAR
C CLEAR THE PRINTOUT ARRAY
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ DDDD(1001),AR(10)
COMMON /MD/ MDX,MDY
I2=MDX*MDY
DO 10 I1=1,I2
AR(I1)=' '
10 CONTINUE
END
SUBROUTINE GWOUT
C WRITES OUT THE GRAPH IMAGE
IMPLICIT INTEGER (A-Z)
DATA I111 /0/
COMMON /CREGNO/ REGNO
COMMON /IO/ CID,COD
COMMON /CASA/ DDDD(1001),AR(100,1)
DIMENSION ARE(1)
EQUIVALENCE (AR(1,1),ARE(1))
COMMON /MD/ MDX,MDY
DATA YLEN /1/
I111=I111+1
XMAX=0
YMAX=0
XMIN=MDX
YMIN=MDY
I12=MDX*MDY
DO 10 I11=1,I12
IF(ARE(I11) .EQ. ' ') GO TO 10
I2=MOD(I11,MDX)
IF(I2 .EQ. 0) I2=MDX
I1=(I11/MDX)+1
IF(I2 .GT. XMAX) XMAX=I2
IF(I2 .LT. XMIN) XMIN=I2
IF(I1 .GT. YMAX) YMAX=I1
IF( I1 .LT. YMIN) YMIN=I1
10 CONTINUE
XMAX=XMAX+YLEN
YMAX=YMAX+YLEN
XMIN=XMIN-YLEN
YMIN=YMIN-YLEN
IF( XMIN .LT. 1 ) XMIN=1
IF(YMIN .LT. 1) YMIN=1
IF(XMAX .GT. MDX) XMAX=MDX
IF(YMAX .GT. MDY) YMAX=MDY
DO 30 I1=YMAX,YMIN,-1
I3=XMAX
DO 31 I4=XMIN,XMAX
IF(AR(I3,I1) .NE. ' ') GO TO 32
I3=I3-1
31 CONTINUE
32 CONTINUE
WRITE(5,101)(AR(I2,I1),I2=XMIN,I3)
DO 40 I47=XMIN,I3
AR(I47,I1)=' '
40 CONTINUE
30 CONTINUE
101 FORMAT(' ',130A1)
END
SUBROUTINE CSRG (MODE)
IMPLICIT INTEGER (A-Z)
COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
COMMON /RECC/ RECCNT,RECLIM
COMMON /CE2SW/ E2SW,E2CNT
COMMON /CDQCS/ DQCSRG
COMMON /CSEQ/ SEQ(100),MSEQ(100)
COMMON /ACARR/ ACAR(80)
COMMON /FRDIR/ FRDIR
COMMON /OTHRING/ ORC,ORING(100)
COMMON /RNGGR/ RNGGR
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100),BNDH(6,100)
DIMENSION AREQ(10)
EQUIVALENCE (AREQ(1),AR(1,1))
DIMENSION EREQ(10)
EQUIVALENCE (EREQ(1),ER(1,1))
DIMENSION BREQ(10)
EQUIVALENCE (BREQ(1),BR(1,1))
COMMON /STPOS/ STPOS
COMMON /CPOSW/ POSW
COMMON /IO/ CID,COD
DATA COD /1/
COMMON /QSCALE/ SCALE,SCC
DATA SCC /80/
DATA SCALE /60/
DIMENSION RINGT(100)
E2CNT=0
SCALE=SCC
P1LIM=990
P2LIM=1990
P3LIM=290
RECLIM=40
DO 90 I1=1,NUMB
AR(4,I1)=I1
90 CONTINUE
IF(MODE .EQ. 1) CALL NMORGAN
DO 900 I1=1,NUMB
SEQ(I1)=AR(3,I1)
MSEQ(I1)=AR(4,I1)
AR(4,I1)=0
AR(3,I1)=0
DO 91 I2=5,10
BNDH(I2-4,I1)=AR(I2,I1)
91 CONTINUE
900 CONTINUE
I13=NUMB*6
DO 12 I1=1,I13
BREQ(I1)=0
BREQ(I1+600 )=0
BREQ(I1+1200)=0
BREQ(I1+1800)=0
EREQ(I1)=0
12 CONTINUE
AR(3,1)=500
AR(4,1)=500
STPOS=0
FRDIR=0
CALL SAFMAF
CALL ELIMEND
CALL RINGGG (0,RINGT,CRINGT,RET)
CALL BRANCH
DO 1047 I1=1,100
ORING(I1)=0
1047 CONTINUE
ORC=1
DO 92 I1=1,NUMB
AR(1,I1)=I1
DO 93 I2=5,10
AR(I2,I1)=BNDH(I2-4,I1)
93 CONTINUE
92 CONTINUE
END
SUBROUTINE RINGGG (MODE,BRATAR,BRATC,RET)
C-----------------------------------------------------------------------
C IN PUSH1 WD1=ATOM POINTER WD2=NEIGHBOR WD3=NEXT PLACE TO STOR
C IN TEMAR
IMPLICIT INTEGER (A-Z)
COMMON /RECC/ RECCNT,RECLIM
DIMENSION BRATAR(10)
COMMON /OTHRING/ ORC,ORING(100)
COMMON /PUSH/ PUSH1(1000),PUSH2(2000),PUSH3(300)
COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
COMMON /ARCC/ SMRAR(90),TEMAR(90)
IC=0
ORC=1
BRATC=0
IF(MODE .NE. 0) IC=MODE-1
PC=4
10 CONTINUE
IC=IC+1
IF(IC .GT. NUMB) GO TO 11
IF(AR(1,IC) .GT. 100) GO TO 10
PUSH1(1)=IC
ICL=0
I2=PC+1
IT=1
TEMAR(1)=IC
SMR=1000
400 CONTINUE
C BEGIN NEIGHBOR SEARCH
ID=4
200 CONTINUE
ID=ID+1
I31=AR(ID,IC)
IF(I31 .GT. 100) GO TO 200
IF(I31 .EQ. 0 )GO TO 500
IF(ID .GT. 10) GO TO 500
IF(I31 .EQ. ICL) GO TO 200
300 CONTINUE
DO 301 I3=1,IT
IF(TEMAR(I3) .EQ. I31) GO TO 302
301 CONTINUE
C THIS ATOM NOT YET ON THE LIST
IT=IT+1
TEMAR(IT)=I31
PUSH1(I2)=IC
PUSH1(I2+1)=ID
PUSH1(I2+2)=IT-1
PUSH1(I2+3)=ICL
I2=I2+PC
IF(I2 .LE. P1LIM) GO TO 5051
TYPE 5052
5052 FORMAT(' PUSH1 OVERFLOW'/)
RECCNT=1000000
RETURN
5051 CONTINUE
ICL=IC
IC=I31
GO TO 400
302 CONTINUE
IF(I3 .NE. 1) GO TO 200
C LOOP BACK TO STARTING POINT
IF(IT .GE. SMR) GO TO 200
C THE PROGRAM CAN ONLY HANDLEUP TO 7 MEMBERED RINGS
C ABORT ALL LARGER RINGS
IF(IT .GT. 7) GO TO 200
C SEE IF ANY ATOM IN THIS RING IS NOT POSITIONED
DO 950 I95=1,IT
I96=TEMAR(I95)
IF(AR(3,I96) .EQ. 0) GO TO 951
950 CONTINUE
C ALL ATOMS POSITIONED
GO TO 200
951 CONTINUE
C RING IS SMALLER SAVE IT
SMR=IT
DO 304 I32=1,IT
SMRAR(I32)=TEMAR(I32)
304 CONTINUE
GO TO 200
500 CONTINUE
C POP THE STACK
I2=I2-PC
IC=PUSH1(I2)
ID=PUSH1(I2+1)
IT=PUSH1(I2+2)
ICL=PUSH1(I2+3)
IF(I2 .NE. 1) GO TO 200
600 CONTINUE
C POPPED BACK TO BASE
IF(SMR .EQ. 1000) GO TO 10
C THERE IS A RING
C FIRST ATOM IN RING MUST BE POSITIONED
IF(AR(3,IC) .NE. 0) GO TO 606
C MARK THIS RING AS A NON CENTRAL RING
DO 607 I6=1,SMR
I61=SMRAR(I6)
ORING(I61)=ORC
607 CONTINUE
ORC=ORC+1
GO TO 10
606 CONTINUE
I77=SMRAR(2)
IF(AR(3,I77) .NE. 0) GO TO 77
C SECOND ATOM OF RING NOT POSITIONED
I78=SMRAR(SMR)
IF(AR(3,I78) .EQ. 0) GO TO 77
C LAST ATOM OF RING IS POSITIONED REVERSE THE RING LIST
DO 78 I79=SMR,2,-1
SMRAR(I79)=SMRAR(I79-1)
78 CONTINUE
SMRAR(1)=I78
77 CONTINUE
CALL POSITION (SMR,SMRAR,MODE,RET)
C IF NON CENTRAL RING CANT BE POSITIONED INCREASE LEG
IF(RET .NE. 0) RETURN
C ELIMINATE ATOMS IN RING WITH ONLY TWO RING NEIGHBORS
DO 601 I6=1,SMR
I61=SMRAR(I6)
I63=0
DO 602 I62=5,10
I622=AR(I62,I61)
IF(I622 .GT. 0 .AND. I622 .LT. 200) I63=I63+1
IF(I622 .LT. 200) GO TO 602
C PUT THIS BRANCH ON BRATAR
I622=I622-200
DO 6022 I6022=1,BRATC
IF(BRATAR(I6022) .EQ. I622) GO TO 602
6022 CONTINUE
C OK PUT IT ON
BRATC=BRATC+1
BRATAR(BRATC)=I622
602 CONTINUE
IF(I63 .NE. 2) GO TO 601
C ELIMINATE THIS ATOM
AR(1,I61)=AR(1,I61)+100
DO 603 I62=5,10
I64=AR(I62,I61)
IF(I64 .EQ. 0 .OR. I64 .GT. 100) GO TO 603
AR(I62,I61)=I64+100
DO 605 I65=5,10
IF(AR(I65 ,I64) .EQ. I61) GO TO 6061
605 CONTINUE
CALL WO ('R605')
6061 CONTINUE
AR(I65,I64)=AR(I65,I64)+100
603 CONTINUE
601 CONTINUE
GO TO 10
11 CONTINUE
END
SUBROUTINE BRANCH
IMPLICIT INTEGER (A-Z)
COMMON /RECC/ RECCNT,RECLIM
DATA RECLIM /300/
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
RECCNT=0
DO 9 I9=1,6
REP=0
DO 10 I1=1,NUMB
IF(AR(3,I1) .NE. 0) GO TO 10
DO 20 I2=5,10
I3=AR(I2,I1)
IF(I3 .EQ. 0) GO TO 21
IF(I3 .GT. 100) I3=I3-100
IF(I3 .GT. 100) I3=I3-100
IF(AR(3,I3) .EQ. 0) GO TO 20
CALL RECPOS (I3,I1,RET)
IF(RECCNT .GE. RECLIM) RETURN
REP=REP+RET
GO TO 21
20 CONTINUE
21 CONTINUE
10 CONTINUE
IF(REP .EQ. 0 .AND. I9 .NE. 1) GO TO 99
9 CONTINUE
99 CONTINUE
END
SUBROUTINE WO (I17)
IMPLICIT INTEGER (A-Z)
COMMON /CREGNO/ REGNO
COMMON /CPOSW/ POSW
COMMON /CE2SW/ E2SW,E2CNT
DATA E2SW /0/
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /IO/ CID,COD,E2CID
COMMON /CRPIC/ RHGH,RPIC(48)
E2CNT=E2CNT+1
IF(E2CNT .NE. 1) RETURN
WRITE (E2CID,102) REGNO
102 FORMAT(1X,1I9)
RHGH=1
TYPE 108
108 FORMAT(' STRUCTURE CANT BE DISPLAYED')
30 CONTINUE
DO 10 I1=1,NUMB
DO 20 I2=10,5,-1
IF(AR(I2,I1) .NE. 0) GO TO 21
20 CONTINUE
21 CONTINUE
IJK=MOD(AR(1,I1),100)
DO 930 I3=1,I2
AR(I3,I1)=MOD(AR(I3,I1),100)
930 CONTINUE
WRITE(5,101) IJK,AR(2,I1),(AR(I4,I1),I4=5,I2)
10 CONTINUE
101 FORMAT(1X,1I3,1X,1A2,1X,8I4)
NUMB=0
DO 50 I1=1,10
AR(I1,1)=0
50 CONTINUE
END
SUBROUTINE POSITION (CNT,STR,MODE,RET)
IMPLICIT INTEGER (A-Z)
COMMON /FRDIR/ FRDIR
DIMENSION RNGDIR(56)
DATA (RNGDIR(I1),I1=1,56) /
1 3,3,1,1,2,2,2,3,
2 4,1,1,2,2,3,3,4,
3 5,5,1,2,2,3,4,5,
4 6,6,1,3,3,3,5,6,
5 7,7,1,3,3,4,6,7,
6 0,0,0,0,0,0,0,0,
7 0,0,0,0,0,0,0,0/
DIMENSION TSTR(20)
COMMON /RNGGR/ RNGGR
COMMON /STPOS/ STPOS
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /REVT/ REVT(8)
DATA (REVT(I1),I1=1,8)/ 5,6,7,8,1,2,3,4/
DIMENSION STR(10)
DIMENSION DIRT(140)
DIMENSION T5(10,7),T6(12,7)
1 ,T7(14,7),T3(12,7),T4(8,7)
DATA (DIRT(I1),I1=1,140)/
1 0,0,0,0,0,0,0,0,0,0,
2 0,0,0,0,0,0,0,0,0,0,
3 2,4,7,3,6,8,2,5,8,1,
4 4,6, 0,0,0,0,0,0,0,0,
5 1,3,5,7,2,4,6,8, 0,0,
6 0,0,0,0,0,0,0,0,0,0,
7 1,3,5,6,8,1,2,4,5,7,
8 0,0,0,0,0,0,0,0,0,0,
9 1,2,4,5,6,8,3,4,6,7,8,2,
1 0,0,0,0,0,0,0,0,
2 1,2,3,4,5,6,8,1,2,4,
3 5,6,7,8, 0,0,0,0,0,0,
4 0,0,0,0,0,0,0,0,0,0,
5 0,0,0,0,0,0,0,0,0,0/
DATA ((T3(I1,I2),I1=1,12),I2=1,7) /
1 5,6,4,3,1,2,12,10,11,8,9,7,
2 7,8,2,4,5,6,7,1,6,3,8,5,
3 4,5,2,10,7,8,4,1,8,3,5,7,
4 5,6,7,10,2,3,5,1,3,4,6,5,
5 12,14,3,13,2,4,12,1,4,5,14,2,
6 0,0,0,0,0,0,0,0,0,0,0,0,
7 0,0,0,0,0,0,0,0,0,0,0,0/
DATA ((T4(I1,I2),I1=1,8 ),I2=1,7) /
1 8,3,4,10,5,6,1,2,
2 3,4,1,2,7,8,6,5,
3 3,10,1,2,4,5,7,8,
4 4,10,1,7,5,6,2,3,
5 5,13,1,3,12,14,2,4,
6 0,0,0,0,0,0,0,0,
7 0,0,0,0,0,0,0,0/
DATA ((T5(I1,I2),I1=1,10),I2=1,7) /
1 8,3,10,1,2,8,5,6,10,4,
2 3,4,1,5,6,3,7,8,1,2,
3 3,10,1,7,8,3,4,5,1,2,
4 4,10,1,2,3,4,5,6,1,7,
5 5,13,1,2,4,5,12,14,1,3,
6 0,0,0,0,0,0,0,0,0,0,
7 0,0,0,0,0,0,0,0,0,0/
DATA ((T6(I1,I2),I1=1,12),I2=1,7) /
1 8,5,6,10,1,2,3,6,1,4,2,5,
2 3,7,8,1,5,6,4,8,5,2,6,7,
3 3,4,5,1,7,8,10,5,7,2,8,4,
4 4,5,6,1,2,3,10,11,12,7,8,9,
5 5,12,14,1,2,4,13,14,2,3,4,12,
6 0,0,0,0,0,0,0,0,0,0,0,0,
7 0,0,0,0,0,0,0,0,0,0,0,0/
DATA ((T7(I1,I2),I1=1,14),I2=1,7) /
1 8,5,3,6,10,1,2,8,5,6,10,1,4,2,
2 3,7,4,8,1,5,6,3,7,8,1,5,2,6,
3 3,4,10,5,1,7,8,3,4,5,1,7,2,8,
4 4,5,10,6,1,2,3,4,5,6,1,2,7,3,
5 5,12,13,14,1,9,10,5,6,7,1,2,3,4,
6 0,0,0,0,0,0,0,0,0,0,0,0, 0,0,
7 0,0,0,0,0,0,0,0,0,0,0,0, 0,0/
DIMENSION LENT(140)
DATA (LENT(I1),I1=1,140)/
1 1,1,1,1,1,1,1,1,1,1,
2 1,1,1,1,1,1,1,1,1,1,
3 1,1,2,2,1,1,1,2,1,2,
4 1,1,1,1,1,1,1,1,1,1,
5 1,1,1,1,1,1,1,1,1,1,
6 1,1,1,1,1,1,1,1,1,1,
7 1,2,1,1,1,1,1,1,1,2,
8 1,1,1,1,1,1,1,1,1,1,
9 1,1,1,1,1,1,1,1,1,1,
1 1,1,1,1,1,1,1,1,1,1,
2 1,1,2,1,1,2,2,1,2,2,
3 1,1,2,1,1,1,1,1,1,1,
4 1,1,1,1,1,1,1,1,1,1,
5 1,1,1,1,1,1,1,1,1,1/
COMMON /QSCALE/ SCALE
C BEGINNING OF CODE
RET=0
IF(FRDIR .EQ. 0) GO TO 3000
FD1=((CNT-3)*8)+FRDIR
FRDIR=0
NPH=RNGDIR(FD1)
GO TO 1001
3000 CONTINUE
IF(STPOS .NE. 0) GO TO 13
STPOS=1
ORCNT=6
OPH=1
GO TO 14
13 CONTINUE
I1=STR(1)
DO 10 I2=5,10
IF(AR(I2,I1) .EQ. STR(2)) GO TO 11
10 CONTINUE
CALL WO ('WE10')
11 CONTINUE
ORCNT=BR(I2-4,I1)
I97=STR(2)
IF(ORCNT .GT. 100 .OR. AR(3,I97) .EQ. 0) GO TO 1002
I99=STR(1)
STR(1)=I97
STR(2)=I99
I95=3
DO 1004 I96=CNT,3,-1
TSTR(I95)=STR(I96)
I95=I95+1
1004 CONTINUE
DO 1003 I98=3,CNT
STR(I98)=TSTR(I98)
1003 CONTINUE
1002 CONTINUE
IF(ORCNT .GT. 100) ORCNT=ORCNT-100
OPH=CR(I2-4,I1)
12 CONTINUE
14 CONTINUE
GO TO (1,1,300,400,500,600,700,800,900),ORCNT
300 CONTINUE
NPH=T3(OPH,CNT-2)
GO TO 1000
400 CONTINUE
NPH=T4(OPH,CNT-2)
GO TO 1000
500 CONTINUE
NPH=T5(OPH,CNT-2)
GO TO 1000
600 CONTINUE
NPH=T6(OPH,CNT-2)
GO TO 1000
700 CONTINUE
NPH=T7(OPH,CNT-2)
GO TO 1000
1000 CONTINUE
IF(MODE .EQ. 0) GO TO 1001
C NON CENTRAL RING USE PHASE 1
NPH=1
1001 CONTINUE
OFF=(CNT-2)*20
QOFF=(((NPH-1)/ CNT)* CNT)+1
STR(CNT+1)=STR(1)
DO 20 I3=1,CNT
I4=DIRT(OFF+NPH)
I5=STR(I3)
I6=STR(I3+1)
IF(AR(3,I6) .NE. 0) GO TO 2200
LX=AR(3,I5)
LY=AR(4,I5)
GO TO (31,32,33,34,35,36,37,38),I4
31 CONTINUE
DX=0
DY=1
GO TO 39
32 CONTINUE
DX=1
DY=1
GO TO 39
33 CONTINUE
DX=1
DY=0
GO TO 39
34 CONTINUE
DX=1
DY=-1
GO TO 39
35 CONTINUE
DX=0
DY=-1
GO TO 39
36 CONTINUE
DX=-1
DY=-1
GO TO 39
37 CONTINUE
DX=-1
DY=0
GO TO 39
38 CONTINUE
DX=-1
DY=1
GO TO 39
39 CONTINUE
IL=LENT(OFF+NPH)
I92 =LX+(DX*SCALE*IL)
I93 =LY+(DY*SCALE*IL)
DO 2000 I91=1,NUMB
IF(AR(3,I91) .NE. I92) GO TO 2000
IF(I91 .EQ. I6) GO TO 2000
IF(AR(4,I91) .NE. I93) GO TO 2000
C NODE OVERLAP
C IF NON CENTRAL RING OVERLAPS BALK
IF(MODE .EQ. 0) GO TO 2002
RET=1
RETURN
2002 CONTINUE
I92=I92-20
I93=I93+20
GO TO 2001
2000 CONTINUE
2001 CONTINUE
AR(3,I6)=I92
AR(4,I6)=I93
2200 CONTINUE
DO 40 I7=5,10
IF(AR(I7,I5) .EQ. I6) GO TO 41
40 CONTINUE
CALL WO ('POS40')
41 CONTINUE
BR(I7-4,I5)=CNT
CR(I7-4,I5)=NPH
ER(I7-4,I5)=I4
DO 42 I8=5,10
IF(AR(I8,I6) .EQ. I5) GO TO 43
42 CONTINUE
CALL WO ('POS42')
43 CONTINUE
BR(I8-4,I6)=CNT +100
CR(I8-4,I6)=NPH
ER(I8-4,I6)=REVT(I4)
NPH=NPH+1
NPHT=MOD(NPH,CNT)
IF(NPHT .EQ. 1 ) NPH=QOFF
20 CONTINUE
IP=IP+1
IF(RNGGR .EQ. 1)
1 CALL GMOL (0)
RETURN
800 CONTINUE
900 CONTINUE
1 CONTINUE
CALL WO ('POEXT')
END
SUBROUTINE NDIRECT (I1,I2,I3,CNT,NDIR)
IMPLICIT INTEGER (A-Z)
COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
DIMENSION BENDA(8)
DATA (BENDA(I1),I1=1,8)/ 4,7,7,7,2,3,3,3/
COMMON /IO/ CID,COD
COMMON /REVT/ REVT(8)
DIMENSION NDT(4,56)
DATA ((NDT(I1,I2),I1=1,4),I2=1,56) /
1 6,4,0,1, 8,2,0,5, 8,5,0,2, 1,6,0,4, 1,4,0,6, 5,2,0,8,
2 2,4,0,7, 8,6,0,3, 6,3,0,8, 2,7,0,4, 7,4,0,2, 3,8,0,6,
3 1,5,0,3, 5,1,0,7, 7,3,0,1, 3,7,0,5,
4 4,8,0,2, 6,2,0,8, 2,6,0,4, 8,4,0,6,
5 3,5,0,8, 5,7,0,2, 1,3,0,6, 1,7,0,4,
6 1,3,7,5, 5,3,7,1, 1,5,3,7, 1,5,7,3,
7 2,4,8,6, 2,6,8,4, 4,2,6,8, 4,8,6,2,
8 2,5,8,1, 4,1,6,5, 3,6,8,7, 2,4,7,3,
9 7,4,1,8, 3,5,8,6, 5,7,2,8, 1,3,6,4,
1 1,4,5,7, 1,5,6,3, 1,5,8,3, 1,2,5,7,
2 1,2,6,4, 2,6,7,4, 2,3,6,8, 2,5,6,8,
3 1,4,8,6, 3,4,8,6, 4,5,8,2, 4,7,8,2,
4 3,7,8,5, 3,6,7,1, 2,3,7,5, 3,4,7,1/
C BEGINNING OF CODE
NDIR=0
IF(I2 .NE. 0) GO TO 12
NDIR=REVT(I1)
IF(BENDARM .EQ. 2) NDIR=BENDA(I1)
GO TO 11
RETURN
12 CONTINUE
I41=1
IF(I3 .NE. 0) I41=25
DO 10 I4=I41,56
CALL ND1(I1,I2,I3,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
IF(I4 .GE. 13 .AND. I4 .LE. 20) GO TO 10
CALL ND1(I1,I3,I2,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I2,I1,I3,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I2,I3,I1,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I3,I1,I2,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
CALL ND1(I3,I2,I1,NDT(1,I4),NDIR)
IF(NDIR .NE. 0) GO TO 11
10 CONTINUE
CALL WO ('ND10')
C WRITE(COD,101) I1,I2,I3
C101 FORMAT(1X,3I4)
RETURN
11 CONTINUE
IF(CNT .EQ. 0) GO TO 20
C SAME DIRECTION GENERATED AGAIN
IF(CNT .EQ. 1) NDIR=MOD(NDIR,8)+1
IF(CNT .NE. 2) GO TO 30
NDIR=NDIR-1
IF(NDIR .EQ. 0) NDIR=8
30 CONTINUE
IF(CNT .NE. 3) GO TO 40
NDIR=MOD(NDIR,8)+1
NDIR=MOD(NDIR,8)+1
40 CONTINUE
IF(CNT .NE. 4) GO TO 50
NDIR=NDIR-1
IF(NDIR .EQ. 0) NDIR=8
NDIR=NDIR-1
IF(NDIR .EQ. 0) NDIR=8
50 CONTINUE
RETURN
20 CONTINUE
END
SUBROUTINE ND1 (I1,I2,I3,QAR,NDIR)
IMPLICIT INTEGER (A-Z)
DIMENSION QAR(4)
NDIR=0
IF(I1 .EQ. QAR(1) .AND. I2 .EQ. QAR(2) .AND. I3 .EQ. QAR(3))
1 NDIR=QAR(4)
END
SUBROUTINE INTERSECT (I1,I2,RET)
REAL MM,QM,MC,QC,MX,MY,M1X,M1Y,M2X,M2Y,M3X,M3Y,M4X,M4Y,TT,TB
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
RET=0
I1X=AR(3,I1)
I1Y=AR(4,I1)
I2X=AR(3,I2)
I2Y=AR(4,I2)
MM=1000000.
TT=I1Y-I2Y
TB=I1X-I2X
IF(I1X .NE. I2X) MM=TT/TB
M1X=I1X
M1Y=I1Y
M2X=I2X
M2Y=I2Y
MC=M2Y-(MM*M2X)
DO 10 I3=1,NUMB
IF(I3 .EQ. I1 .OR. I3 .EQ. I2) GO TO 10
I3X=AR(3,I3)
IF(I3X .EQ. 0) GO TO 10
I3Y=AR(4,I3)
M3X=I3X
M3Y=I3Y
DO 20 I4=5,10
I41=AR(I4,I3)
IF(I41 .EQ. 0) GO TO 10
IF(I41 .LT. I3) GO TO 20
IF(I41 .GT. 100) I41=I41-100
IF(I41 .GT. 100) I41=I41-100
IF(I41 .EQ. I1 .OR. I41 .EQ. I2) GO TO 20
I4X=AR(3,I41)
IF(I4X .EQ. 0) GO TO 20
I4Y=AR(4,I41)
C GOT 4 POINTS
QM=1000000.
TT=I3Y-I4Y
TB=I3X-I4X
IF(I3X .NE. I4X)QM=TT/TB
M4X=I4X
M4Y=I4Y
QC=M4Y-(QM*M4X)
IF(QM.EQ.MM) GO TO 21
MX=(QC-MC)/(MM-QM)
IF((M1X-MX)*(MX-M2X).GE.0.AND.(M3X-MX)*(MX-M4X).GE.0) GO TO 60
GO TO 20
21 IF(MC.NE.QC) GO TO 20
IF(ABS(QM).GT.1.0) GO TO 22
IF((M1X-M3X)*(M3X-M2X).GE.0.OR.(M1X-M4X)*(M4X-M2X).GE.0)GOTO60
GO TO 20
22 CONTINUE
IF((M1Y-M3Y)*(M3Y-M2Y).GE.0.OR.(M1Y-M4Y)*(M4Y-M2Y).GE.0) GO TO 60
20 CONTINUE
10 CONTINUE
RETURN
60 CONTINUE
RET=1
END
SUBROUTINE RECPOS (LAT,NAT,RET)
IMPLICIT INTEGER (A-Z)
COMMON /REVT/ REVT(8)
COMMON /FRDIR/ FRDIR
COMMON /QSCALE/ SCALE
COMMON /RECC/ RECCNT,RECLIM
COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
COMMON /PUSH/ PUSH1(1000),PUSH2(2000),PUSH3(300)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
1 ER(6,100)
COMMON /OTHRING/ ORC,ORING(100)
DIMENSION NDAR(3)
PL=12
IP3=1
I2=10
LC=LAT
NC=NAT
600 CONTINUE
IF(I2 .LE. P2LIM) GO TO 5051
TYPE 5052
RECCNT=1000000
RETURN
5052 FORMAT(' PUSH2 OVERFLOW'/)
5051 CONTINUE
DISC=0
DIRC=0
RNGSW=1
RNG=0
RET=0
400 CONTINUE
C BEGIN TO POSITION THIS ATOM
C ASSUMES THAT NEIGHBORS ARE ORDERED ACCORDING TO LENGTH
NDAR(1)=0
NDAR(2)=0
NDAR(3)=0
I41=1
DO 401 I4=5,10
I42=AR(I4,LC)
IF(I42 .EQ. 0) GO TO 4205
IF(I42 .GT. 100) I42=I42-100
IF(I42 .GT. 100) I42=I42-100
IF(AR(3,I42) .EQ. 0) GO TO 401
C FOUND A NEIGHBOR ON LAT WHICH IS POSITIONED
NDAR(I41)=ER(I4-4,LC)
I41=I41+1
401 CONTINUE
4205 CONTINUE
IF(I41 .NE. 1) GO TO 420
C NO NEIGHBORS ARE SET USE DIRECTION 3
NDIR=3
GO TO 471
420 CONTINUE
CALL NDIRECT (NDAR(1),NDAR(2),NDAR(3),DIRC,NDIR)
471 CONTINUE
RECCNT=RECCNT+1
IF(RECCNT .GE. RECLIM) RETURN
C CHANGE LENGTH OF ARM
DISC=DISC+1
IF(DISC .LE. 5) GO TO 410
470 CONTINUE
C CHANGE DIRECTION
DISC=0
DIRC=DIRC+1
IF(DIRC .GE. 4) GO TO 502
C CLEAR POSITIONING OF ATOM
AR(3,NC)=0
AR(4,NC)=0
NCP1=NC+100
NCP2=NC+200
DO 531 I431=5,10
I432=AR(I431,LC)
IF(I432 .EQ. NC .OR. I432 .EQ. NCP1 .OR. I432 .EQ. NCP2)
1 GO TO 532
531 CONTINUE
CALL WO ('RP531')
532 CONTINUE
ER(I431-4,LC)=0
LCP1=LC+100
LCP2=LC+200
DO 533 I433=5,10
I434=AR(I433,NC)
IF( I434 .EQ. LC .OR. I434 .EQ. LCP1 .OR. I434 .EQ. LCP2)
1 GO TO 534
533 CONTINUE
CALL WO ('RP533')
534 CONTINUE
ER(I433-4,NC)=0
I411X=AR(3,NC)
I411Y=AR(4,NC)
GO TO 420
410 CONTINUE
GO TO (411,412,413,414,415,416,417,418),NDIR
411 CONTINUE
AR(3,NC)=AR(3,LC)
AR(4,NC)=AR(4,LC)+(DISC*SCALE)
GO TO 430
412 CONTINUE
AR(3,NC)=AR(3,LC)+(DISC*SCALE)
AR(4,NC)=AR(4,LC)+(DISC*SCALE)
GO TO 430
413 CONTINUE
AR(3,NC)=AR(3,LC)+(DISC*SCALE)
AR(4,NC)=AR(4,LC)
GO TO 430
414 CONTINUE
AR(3,NC)=AR(3,LC)+(DISC*SCALE)
AR(4,NC)=AR(4,LC)-(DISC*SCALE)
GO TO 430
415 CONTINUE
AR(3,NC)=AR(3,LC)
AR(4,NC)=AR(4,LC)-(DISC*SCALE)
GO TO 430
416 CONTINUE
AR(3,NC)=AR(3,LC)-(DISC*SCALE)
AR(4,NC)=AR(4,LC)-(DISC*SCALE)
GO TO 430
417 CONTINUE
AR(3,NC)=AR(3,LC)-(DISC*SCALE)
AR(4,NC)=AR(4,LC)
GO TO 430
418 CONTINUE
AR(3,NC)=AR(3,LC)-(DISC*SCALE)
AR(4,NC)=AR(4,LC)+(DISC*SCALE)
GO TO 430
430 CONTINUE
IF(I411X .EQ. 0 .OR. (I411X .EQ. AR(3,NC) .AND.
1 I411Y .EQ. AR(4,NC))) GO TO 4119
C WRITE(COD,4118) I411X,I411Y,AR(3,NC),AR(4,NC)
C4118 FORMAT(' OLD ',2I5,' NEW ',2I5)
AR(3,NC)=I411X
AR(4,NC)=I411Y
4119 CONTINUE
CALL INTERSECT (LC,NC,RET)
IF(RET .NE. 1) GO TO 4717
AR(3,NC)=0
AR(4,NC)=0
GO TO 470
4717 CONTINUE
NCP1=NC+100
NCP2=NC+200
DO 431 I431=5,10
I432=AR(I431,LC)
IF(I432 .EQ. NC .OR. I432 .EQ. NCP1 .OR. I432 .EQ. NCP2)
1 GO TO 432
431 CONTINUE
CALL WO ('RP431')
432 CONTINUE
ER(I431-4,LC)=NDIR
LCP1=LC+100
LCP2=LC+200
DO 433 I433=5,10
I434=AR(I433,NC)
IF( I434 .EQ. LC .OR. I434 .EQ. LCP1 .OR. I434 .EQ. LCP2)
1 GO TO 434
433 CONTINUE
CALL WO ('RP433')
434 CONTINUE
ER(I433-4,NC)=REVT(NDIR)
IF(ORING(NC) .EQ. 0) GO TO 480
IF(DISC .LT. 2) GO TO 471
C NON CENTRAL RING
FRDIR=NDIR
CALL RINGGG (NC,PUSH3(IP3),RNG,RET)
IF(RET .EQ. 1) GO TO 470
I5=0
RNGSW=2
540 CONTINUE
I5=I5+1
IF(I5 .GT. RNG) GO TO 500
I55=PUSH3(IP3+I5-1)
DO 541 I54=5,10
I51=AR(I54,I55)
IF(I51 .EQ. 0) GO TO 540
IF(I51 .LE. 200) GO TO 541
I51=I51-200
IF(AR(3,I51) .NE. 0) GO TO 542
541 CONTINUE
CALL WO ('RP541')
542 CONTINUE
C SAVE THIS ATOM
PUSH2(I2)=LC
PUSH2(I2+1)=NC
PUSH2(I2+2)=DISC
PUSH2(I2+3)=DIRC
PUSH2(I2+4)=I5
PUSH2(I2+5)=RNG
PUSH2(I2+6)=IP3
PUSH2(I2+7)=RNGSW
PUSH2(I2+8)=I51
PUSH2(I2+9)=NDAR(1)
PUSH2(I2+10)=NDAR(2)
PUSH2(I2+11)=NDAR(3)
IP3=IP3+RNG
IF(IP3 .LE. P3LIM) GO TO 5055
TYPE 5056
RECCNT=1000000
RETURN
5056 FORMAT(' PUSH3 OVERFLOW'/)
5055 CONTINUE
I2=I2+PL
LC=I51
NC=I55
GO TO 600
480 CONTINUE
I5=4
440 CONTINUE
I5=I5+1
IF(I5 .GT. 10) GO TO 500
I51=AR(I5,NC)
IF(I51 .LT. 200) GO TO 440
I51=I51-200
IF(AR(3,I51) .NE. 0) GO TO 440
C SAVE THIS ATOM
PUSH2(I2)=LC
PUSH2(I2+1)=NC
PUSH2(I2+2)=DISC
PUSH2(I2+3)=DIRC
PUSH2(I2+4)=I5
PUSH2(I2+5)=RNG
PUSH2(I2+6)=IP3
PUSH2(I2+7)=RNGSW
PUSH2(I2+8)=I51
PUSH2(I2+9)=NDAR(1)
PUSH2(I2+10)=NDAR(2)
PUSH2(I2+11)=NDAR(3)
I2=I2+PL
LC=NC
NC=I51
GO TO 600
502 CONTINUE
RET=1
500 CONTINUE
I2=I2-PL
IF(I2 .LE. 1) GO TO 700
LC=PUSH2(I2)
NC=PUSH2(I2+1)
DISC=PUSH2(I2+2)
DIRC=PUSH2(I2+3)
I5=PUSH2(I2+4)
RNG=PUSH2(I2+5)
IP3=PUSH2(I2+6)
RNGSW=PUSH2(I2+7)
I51=PUSH2(I2+8)
NDAR(1)=PUSH2(I2+9 )
NDAR(1)=PUSH2(I2+10)
NDAR(1)=PUSH2(I2+11)
IF(RET .EQ. 0) GO TO 501
RET=0
CALL UNPOS (NC)
GO TO 471
501 CONTINUE
GO TO (440,540),RNGSW
700 CONTINUE
END
SUBROUTINE UNPOS (NC)
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
COMMON /PUSH4/ PUSH4(100)
IP4=2
PUSH4(1)=NC
PUSH4(2)=0
DO 10 PP4=1,100
PN=PUSH4(PP4)
IF(PN .EQ. 0) GO TO 11
AR(3,PN)=0
AR(4,PN)=0
DO 20 I1=5,10
I2=AR(I1,PN)
IF(I2 .EQ. 0 .OR. DR(I1-4,PN) .EQ. 0) GO TO 20
IF(I2 .GT. 100) I2=I2-100
IF(I2 .GT. 100) I2=I2-100
IF(AR(3,I2) .EQ. 0) GO TO 20
PUSH4(IP4)=I2
PUSH4(IP4+1)=0
IP4=IP4+1
20 CONTINUE
10 CONTINUE
11 CONTINUE
END
SUBROUTINE ELIMEND
IMPLICIT INTEGER (A-Z)
DIMENSION TAR1(10),TAR2(10)
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
DO 60 I1=1,NUMB
IF(AR(6,I1) .NE. 0) GO TO 60
C ONLY ONE ATTACHMENT
I2=AR(5,I1)
DO 61 I3=5,10
IF(AR(I3,I2) .EQ. I1) GO TO 62
61 CONTINUE
CALL WO ('EE60')
62 CONTINUE
DR(I3,I2)=1
AR(1,I1)=AR(1,I1)+200
60 CONTINUE
40 CONTINUE
FND=0
DO 10 I1=NUMB,1,-1
IF(AR(1,I1) .GT. 100) GO TO 10
I3=0
DO 20 I2=5,10
IF(AR(I2,I1) .EQ. 0) GO TO 20
IF(AR(I2,I1) .GT. 200) GO TO 20
I3=I3+1
I4=AR(I2,I1)
I41=I2
20 CONTINUE
IF(I3 .GT. 1 .OR. I3 .EQ. 0) GO TO 10
AR(I41,I1)=AR(I41,I1)+200
FND=1
I8=0
DO 400 I9=1,6
IF(DR(I9,I1) .GT. I8) I8=DR(I9,I1)
400 CONTINUE
DO 30 I2=5,10
IF(AR(I2,I4) .EQ. I1) GO TO 31
30 CONTINUE
CALL WO ('EE30')
31 CONTINUE
AR(I2,I4)=AR(I2,I4)+200
AR(1,I1)=AR(1,I1)+200
DR(I2-4,I4)=I8+1
10 CONTINUE
IF(FND .EQ. 1) GO TO 40
DO 50 I1=1,NUMB
IF(AR(1,I1) .LT. 200) GO TO 50
51 CONTINUE
I5=1
DO 95 I2=1,6
TAR1(I2)=0
TAR2(I2)=0
IF(AR(I2+4,I1) .EQ. 0 .OR. DR(I2,I1) .NE. 0 ) GO TO 95
TAR1(I5)=DR(I2,I1)
TAR2(I5)=AR(I2+4,I1)
I5=I5+1
95 CONTINUE
DO 80 I2=1,6
I4=0
DO 70 I3=1,6
IF(DR(I3,I1) .LE. TAR1(I2)) GO TO 70
TAR1(I5)=DR(I3,I1)
TAR2(I5)=AR(I3+4,I1)
I4=I3
70 CONTINUE
IF(I4 .EQ. 0) GO TO 81
DR(I4,I1)=-1
I5=I5+1
80 CONTINUE
81 CONTINUE
DO 90 I2=1,6
AR(I2+4,I1)=TAR2(I2)
DR(I2,I1)=TAR1(I2)
90 CONTINUE
50 CONTINUE
END
SUBROUTINE SAFMAF
IMPLICIT INTEGER (A-Z)
DIMENSION STPAR(12)
DATA (STPAR(I1),I1=1,12) /500,500,700,700,300,300
1 ,700,300,300,700,300,500/
COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
COMMON /PUSH4/ PUSH4(100)
STC=1
DO 30 I3=1,NUMB
IF(AR(3,I3) .NE. 0 .AND. I3 .NE. 1) GO TO 30
AR(3,I3)=STPAR(STC)
AR(4,I3)=STPAR(STC+1)
STC=STC+2
IP4=2
PUSH4(1)=I3
PUSH4(2)=0
DO 10 PP4=1,100
PN=PUSH4(PP4)
IF(PN .EQ. 0) GO TO 11
DO 20 I1=5,10
I2=AR(I1,PN)
IF(I2 .EQ. 0) GO TO 20
IF(AR(3,I2) .NE. 0) GO TO 20
AR(3,I2)=AR(3,I2)-1
PUSH4(IP4)=I2
PUSH4(IP4+1)=0
IP4=IP4+1
20 CONTINUE
10 CONTINUE
11 CONTINUE
30 CONTINUE
DO 40 I1=1,NUMB
AR(3,I1)=AR(3,I1)+1
40 CONTINUE
END
SUBROUTINE NMORGAN
IMPLICIT INTEGER (A-Z)
COMMON /CASA/ NUMB,AR(1000)
COMMON /IO/ CID,COD,FILSIZ,ICNT
COMMON /CPOSW/ POSW
COMMON /NMOR/ NN(100),EV(100),PST(100),SA(100)
1 ,Z(2,100),ATS(100),AT(100),ASS(100)
2 ,SUBQ(100),SUBS(100),SUBT(100)
DIMENSION ZS(2)
EQUIVALENCE (ZS(1),Z(1,1))
I11=0
DO 10 I1=1,NUMB
DO 20 I2=5,10
IF(AR(I2+I11) .EQ. 0) GO TO 21
20 CONTINUE
I2=11
21 CONTINUE
AT(I1)=AR(2+I11)
I2=I2-5
NN(I1)=I2
EV(I1)=I2
SA(I1)=I2
I11=I11+10
10 CONTINUE
OK=0
30 CONTINUE
CALL SORT (SA,NUMB,1)
NK=1
I2=SA(1)
PST(1)=EV(1)
DO 50 I1=2,NUMB
PST(I1)=EV(I1)
IF(SA(I1) .EQ. I2) GO TO 50
NK=NK+1
I2=SA(I1)
50 CONTINUE
IF(NK .LE. OK) GO TO 51
OK=NK
I11=0
DO 60 I1=1,NUMB
I2=NN(I1)
I5=0
IF(I2 .EQ. 0) GO TO 72
DO 70 I3=1,I2
I4=AR(I3+4+I11)
IF(I4 .GE. 1 .AND. I4 .LE. 100) GO TO 71
TYPE 101,I1,I2
101 FORMAT(' NMORGAN ',2I3/)
RETURN
71 CONTINUE
I5=I5+PST(I4)
70 CONTINUE
72 CONTINUE
EV(I1)=I5
SA(I1)=I5
I11=I11+10
60 CONTINUE
GO TO 30
51 CONTINUE
IF(POSW .NE. 0) GO TO 89
KUMB=(NUMB*10)
WRITE (COD,102)(AR(I111),I111=1,KUMB,10)
WRITE(COD,102)(EV(I111),I111=1,NUMB)
102 FORMAT(1X,30I4)
WRITE(COD,102)(SA(I111),I111=1,NUMB)
89 CONTINUE
DO 82 I1=1,NUMB
ATS(I1)=0
82 CONTINUE
I13=SA(NUMB)
DO 90 I1=NUMB,1,-1
IF(EV(I1) .NE. I13) GO TO 90
DO 80 I2=1,NUMB
PST(I2)=0
80 CONTINUE
I2=0
I3=1
SA(1)=I1
120 CONTINUE
I2=I2+1
IF(I2 .GT. I3) GO TO 121
I4=SA(I2)
I44=(I4-1)*10
I5=NN(I4)
IF(I5 .EQ. 0) GO TO 132
K6=0
DO 100 I6=1,I5
I7=AR(I6+4+I44)
ZS(3+K6)=I7
ZS(1+K6)=EV(I7)
ZS(2+K6)=AT(I7)
K6=K6+3
100 CONTINUE
CALL SORT (Z,I5,3)
K6=(I5-1)*3
DO 110 I6=I5,1,-1
I8=ZS(3+K6)
DO 130 I7=1,I3
IF(I8 .EQ. SA(I7)) GO TO 131
130 CONTINUE
132 CONTINUE
I3=I3+1
SA(I3)=I8
PST(I3)=AT(I8)
IF(AT(I8) .LT. ATS(I3)) GO TO 90
C THE ATOM SEQUENCE OF DEVELOPING STRUCTURE IS GTE
IF(AT(I8) .EQ. ATS(I3)) GO TO 138
131 CONTINUE
DO 139 I18=1,NUMB
ATS(I18)=0
139 CONTINUE
138 CONTINUE
K6=K6-3
110 CONTINUE
GO TO 120
121 CONTINUE
DO 140 I2=1,NUMB
ATS(I2)=PST(I2)
ASS(I2)=SA(I2)
140 CONTINUE
I11=I1
90 CONTINUE
DO 150 I1=1,NUMB
Z(2,I1)=I1
Z(1,I1)=ASS(I1)
150 CONTINUE
CALL SORT (Z,NUMB,2)
IF(POSW .EQ. 0)
1 WRITE(COD,102)(Z(1,I111),Z(2,I111),I111=1,NUMB)
I11=0
DO 160 I1=1,NUMB
I2=NN(I1)
DO 170 I3=1,I2
I4=AR(I3+4+I11)
AR(I3+4+I11)=Z(2,I4)
170 CONTINUE
AR(1+I11)=Z(2,I1)
IF(I2 .GT. 1) CALL SORT (AR(5+I11),I2,1)
I11=I11+10
160 CONTINUE
CALL SORT (AR,NUMB,10)
C IF(POSW .EQ. 0) CALL PRAR (AR,NUMB,'NMORG')
END